home *** CD-ROM | disk | FTP | other *** search
/ Monster Media 1994 #2 / Monster Media No. 2 (Monster Media)(1994).ISO / clipper / tcmclp.zip / TCMCLIP.PRG < prev   
Text File  |  1994-05-21  |  39KB  |  1,312 lines
  1. *┌──────────────────────────────────────────────────────────────────────────┐
  2. *│    TCMCLIP    Version 1.01    Created: 12/09/87    Revised: 05/21/94     │
  3. *│                                                                          │
  4. *│          Author: Todd C. MacDonald    Compuserve ID: 72274,2252          │
  5. *└──────────────────────────────────────────────────────────────────────────┘
  6. *
  7. * The is an original work by Todd C. MacDonald and is hereby placed in the
  8. * public domain.
  9. *
  10. * As of 5/21/94, this file had 976 downloads from CIS and still counting.
  11. * Though this code may have been "good" for it's time, I certainly wouldn't
  12. * recommend it for a 5.x programmer.  At any rate, seeing as people are still
  13. * downloading it, I modified it strictly to make it compatible with Clipper
  14. * 5.x.  It is still Summer '87 code, however.  I also removed the restrictions
  15. * I had placed on the previous version.
  16. *
  17. * This program demonstrates the use of some routines for menus & windows &
  18. * this & that for Clipper Summer '87 applications.  You may freely use and
  19. * distribute this code as you see fit.
  20. *
  21. * ─────────────────────────────── A few notes ───────────────────────────────
  22. *
  23. * Some routines require one of the SCRNPLAY functions.  They are available
  24. * from their author and are also public domain:
  25. *
  26. *   Rick Whitt, SysOp
  27. *   dBoard BBS - Winston-Salem, NC
  28. *   (919) 768-3043
  29. *
  30. * In S'87, I prefaced variable names according to their scope or purpose:
  31. *
  32. *   a = array (private or public)
  33. *   f = file variable
  34. *   p = public memory variable
  35. *   l = local (any variable not of the other types)
  36. *
  37. * I call procedures with the same syntax as a function (The compiler doesn't
  38. * care and "DO xyz WITH" is too wordy for me.
  39. *
  40. * Clipper is a trademark of Computer Associates and is copyrighted and all
  41. * that jazz...
  42. *
  43. * ─────────────────────────── On with the demo... ───────────────────────────
  44. *
  45. * To compile and link this demo program, type the following:
  46. *
  47. *   C> CLIPPER TCMCLIP
  48. *   C> TLINK TCMCLIP+CHGATTR,,,CLIPPER+EXTEND
  49. *        -OR-
  50. *      LINK TCMCLIP+CHGATTR,,,CLIPPER+EXTEND
  51. *        -OR-
  52. *      PLINK86 FI TCMCLIP,CHGATTR LIB CLIPPER,EXTEND
  53. *        -OR-
  54. *      RTLINK FI TCMCLIP,CHGATTR
  55. *        -OR-
  56. *      BLINKER FI TCMCLIP,CHGATTR
  57. *
  58. * To run the demo:
  59. *
  60. *   C> TCMCLIP
  61. *
  62. *
  63. * ───────────────────────── demo source begins here ──────────────────────────
  64.  
  65. * Get the starting time
  66. lStartTime=time()
  67.  
  68. * set up the environment
  69. set cursor off
  70. set scoreboard off
  71. set bell off
  72. set escape on
  73.  
  74. * Keystroke mnemonics
  75. kNull      = 0
  76. kEnter     = 13
  77. kBackSpace = 8
  78. kEsc       = 27
  79. kHome      = 1
  80. kEnd       = 6
  81. kPgUp      = 18
  82. kPgDn      = 3
  83. kUArrow    = 5
  84. kDArrow    = 24
  85. kLArrow    = 19
  86. kRArrow    = 4
  87. kInsert    = 22
  88. kTab       = 9
  89. kCtrlHome  = 29
  90. kCtrlEnd   = 23
  91. kCtrlPgUp  = 31
  92. kCtrlPgDn  = 30
  93. kF2        = -1
  94. kF3        = -2
  95. kF4        = -3
  96. kF5        = -4
  97. kF6        = -5
  98. kF7        = -6
  99. kF8        = -7
  100. kF9        = -8
  101. kF10       = -9
  102.  
  103. * Set up the windowing variables
  104. lMaxWinds = 5
  105. public aWindColor[lMaxWinds], aWindow[lMaxWinds]
  106. public aWindT[lMaxWinds], aWindL[lMaxWinds], aWindB[lMaxWinds], aWindR[lMaxWinds]
  107. public pWindIndex, pWindFrame, pShadow, pExplode, pExpFactor, pExpDelay
  108. pWindIndex = 0            && Used by windowing routines to keep track of windows
  109. pWindFrame = '┌─╖║╝═╘│ '  && Default window frame characters
  110. pShadow    = .t.          && .t. to paint shadows around windows, .f. otherwise
  111. pExplode   = .t.          && .t. for exploding windows, .f. otherwise
  112. pExpFactor = 1            && lower for more "stages" in the explosion, higher for less
  113. pExpDelay  = 0            && increase this to slow down the exploding effect
  114.  
  115. * Summer '87 doesn't provide windows so we have to do our own relative addressing
  116. lLogoT  = 14
  117. lLogoL  = 43
  118. lLogoB  = lLogoT+8
  119. lLogoR  = lLogoL+34
  120. lMenuT  = 1
  121. lMenuL  = 2
  122. lMenuB  = lMenuT+6
  123. lMenuR  = lMenuL+39
  124. lCloseT = 1
  125. lCloseL = 2
  126. lCloseB = lCloseT+8
  127. lCloseR = lCloseL+35
  128.  
  129. * Define colors
  130. if iscolor()
  131.   lBackGrnd  = "W+/B"
  132.   pHelpColor = "W/N"
  133.   pHelpHigh  = "GR+/N"
  134.   pHelpHighF = 14
  135.   pHelpHighB = 0
  136.   lLogo      = "N/W"
  137.   lMenuFrame = "BG/B"
  138.   lMenuHead  = "BG+/B"
  139.   lMenuBody  = "W/B"
  140.   lMnuNorm   = "W/B"
  141.   lMnuHilite = "W/RB"
  142.   lMenuSelF  = 14
  143.   lMnuSelB   = 1
  144.   lMnuSelFHi = 14
  145.   lMnuSelBHi = 5
  146.   pErrFrame  = "R+/R"
  147.   pErrHead   = "GR+*/R"
  148.   pErrBody   = "W+/R"
  149.   lClosFrame = "W/GR"
  150.   lClosHead  = "W/GR"
  151.   lClosBody  = "N/GR,GR+*/GR"
  152. else
  153.   lBackGrnd  = "W+/N"
  154.   pHelpColor = "W/N"
  155.   pHelpHigh  = "W+/N"
  156.   pHelpHighF = 15
  157.   pHelpHighB = 0
  158.   lLogo      = "N/W"
  159.   lMenuFrame = "W+/N"
  160.   lMenuHead  = "W+/N"
  161.   lMenuBody  = "W/N,N/W,,,W+/N"
  162.   lMnuNorm   = "W/N"
  163.   lMnuHilite = "N/W"
  164.   lMenuSelF  = 15
  165.   lMnuSelB   = 0
  166.   lMnuSelFHi = 0
  167.   lMnuSelBHi = 7
  168.   pErrFrame  = "N/W"
  169.   pErrHead   = "N*/W"
  170.   pErrBody   = "W/N,N/W,,,W+/N"
  171.   lClosFrame = "W+/N"
  172.   lClosHead  = "W+/N"
  173.   lClosBody  = "W/N,W+*/N"
  174. endif
  175.  
  176. * Make things pretty
  177. lBGchar = '░'
  178. clear
  179. set color to (lBackGrnd)
  180. @ 0, 0, 23, 79 box replicate(lBGchar, 9)
  181. DispLogo()
  182.  
  183. * Whew! Let's go already...
  184. lChoice = 1
  185. do while .t.
  186.   OpenWindow(lMenuT, lMenuL, lMenuB, lMenuR, lMenuFrame, lMenuHead, lMenuBody, 'BY YOUR COMMAND', .f.)
  187.   HelpMsg('Use '+chr(25)+chr(24)+' to highlight option and press Enter; or type capital letter of Option')
  188.   InitMenu(5, lMnuNorm, lMnuHilite, lMenuSelF, lMnuSelB, lMnuSelFHi, lMnuSelBHi)
  189.   MenuPrompt(lMenuT+01, lMenuL+01, ' okay, show me the Windows            ', 20)
  190.   MenuPrompt(lMenuT+02, lMenuL+01, [ what's this "thermometer Bar" thing? ], 27)
  191.   MenuPrompt(lMenuT+03, lMenuL+01, ' yeah, so what about the Menus?       ', 26)
  192.   MenuPrompt(lMenuT+04, lMenuL+01, ' Is that all there is?                ', 2)
  193.   MenuPrompt(lMenuT+05, lMenuL+01, ' get me Outta here                    ', 9)
  194.   lChoice  = MenuChoice(lChoice )
  195.   do case
  196.     case lChoice  = 1
  197.       ClosWindow()
  198.       EraseLogo()
  199.       WindowDemo()
  200.       DispLogo()
  201.     case lChoice  = 2
  202.       ClosWindow()
  203.       EraseLogo()
  204.       BarDemo()
  205.       DispLogo()
  206.     case lChoice  = 3
  207.       Error([Whata'ya mean "what about the menus?"  You've been using them all along!])
  208.       ClosWindow()
  209.     case lChoice  = 4
  210.       ClosWindow()
  211.       EraseLogo()
  212.       IsThatAll()
  213.       DispLogo()
  214.     case lChoice  = 5
  215.       ClosWindow()
  216.       ClosSystem()
  217.       exit
  218.     otherwise
  219.       lChoice = 5
  220.       ClosWindow()
  221.   endcase
  222. enddo
  223.  
  224. * Clean up and go home
  225. set color to
  226. @ 24, 00
  227. @ 23, 00 say ''
  228. set cursor on
  229. quit
  230.  
  231.  
  232. *
  233. procedure WindowDemo
  234. *------------------*
  235.  
  236. lOptT   = 5
  237. lOptL   = 10
  238. lOptB   = lOptT+5
  239. lOptR   = lOptL+30
  240.  
  241. lWind1T = 1
  242. lWind1L = 2
  243. lWind1B = 21
  244. lWind1R = 75
  245.  
  246. lWind2T = 3
  247. lWind2L = 40
  248. lWind2B = 17
  249. lWind2R = 71
  250.  
  251. lWind3T = 5
  252. lWind3L = 7
  253. lWind3B = 7
  254. lWind3R = 65
  255.  
  256. lWind4T = 10
  257. lWind4L = 4
  258. lWind4B = 19
  259. lWind4R = 37
  260.  
  261. lWind5T = 4
  262. lWind5L = 10
  263. lWind5B = 14
  264. lWind5R = 21
  265.  
  266. lExplode   = pExplode
  267. lExpFactor = pExpFactor
  268. lExpDelay  = pExpDelay
  269. lShadow    = pShadow
  270.  
  271. if iscolor()
  272.   lOptFrame = 'W+/BG'
  273.   lOptHead  = 'N/BG'
  274.   lOptBody  = 'B/BG,GR+/B,,,GR+/BG'
  275.   lWn1Frame = 'G+/B'
  276.   lWn1Head  = 'GR+/B'
  277.   lWn1Body  = 'N/B'
  278.   lWn2Frame = 'W+/BG'
  279.   lWn2Head  = 'N/BG'
  280.   lWn2Body  = 'B/BG'
  281.   lWn3Frame = 'W/RB'
  282.   lWn3Head  = 'GR+/RB'
  283.   lWn3Body  = 'N/W'
  284.   lWn4Frame = 'GR+/G'
  285.   lWn4Head  = 'W+/G'
  286.   lWn4Body  = 'N/G'
  287.   lWn5Frame = 'W+/R'
  288.   lWn5Head  = 'BG+/R'
  289.   lWn5Body  = 'N/R'
  290. else
  291.   lOptFrame = 'W/N'
  292.   lOptHead  = 'W+/N'
  293.   lOptBody  = 'W/N,N/W,,,W+/N'
  294.   lWn1Frame = 'W/N'
  295.   lWn1Head  = 'W+/N'
  296.   lWn1Body  = 'W/N,N/W,,,W+/N'
  297.   lWn2Frame = 'W/N'
  298.   lWn2Head  = 'W+/N'
  299.   lWn2Body  = 'W/N,N/W,,,W+/N'
  300.   lWn3Frame = 'W/N'
  301.   lWn3Head  = 'W+/N'
  302.   lWn3Body  = 'W/N,N/W,,,W+/N'
  303.   lWn4Frame = 'W/N'
  304.   lWn4Head  = 'W+/N'
  305.   lWn4Body  = 'W/N,N/W,,,W+/N'
  306.   lWn5Frame = 'W/N'
  307.   lWn5Head  = 'W+/N'
  308.   lWn5Body  = 'W/N,N/W,,,W+/N'
  309. endif
  310.  
  311. OpenWindow(lOptT, lOptL, lOptB, lOptR, lOptFrame, lOptHead, lOptBody, 'WINDOW OPTIONS')
  312. do while .t.
  313.   @ lOptT+1, lOptL+2 say 'Exploding windows:    (Y/N)'
  314.   @ lOptT+2, lOptL+3 say 'Explosion factor:    (1-4)'
  315.   @ lOptT+3, lOptL+4 say 'Explosion delay:    (1-99)'
  316.   @ lOptT+4, lOptL+3 say 'Shadowed windows:    (Y/N)'
  317.   @ lOptT+1, lOptL+21 get pExplode   pict 'Y'
  318.   @ lOptT+2, lOptL+21 get pExpFactor pict '9' range 1,4
  319.   @ lOptT+3, lOptL+21 get pExpDelay  pict '99' range 1,99
  320.   @ lOptT+4, lOptL+21 get pShadow    pict 'Y'
  321.   HelpMsg('PgDn-Done   Esc-Abort')
  322.   ReadGets()
  323.   if lastkey() = kEsc
  324.     ClosWindow()
  325.     exit
  326.   endif
  327.   if Verify('Are the options set the way you want them? [Y/n]')
  328.     ClosWindow()
  329.     OpenWindow(lWind1T, lWind1L, lWind1B, lWind1R, lWn1Frame, lWn1Head, lWn1Body, 'WINDOW 1')
  330.     OpenWindow(lWind2T, lWind2L, lWind2B, lWind2R, lWn2Frame, lWn2Head, lWn2Body, 'WINDOW 2')
  331.     OpenWindow(lWind3T, lWind3L, lWind3B, lWind3R, lWn3Frame, lWn3Head, lWn3Body, 'WINDOW 3')
  332.     OpenWindow(lWind4T, lWind4L, lWind4B, lWind4R, lWn4Frame, lWn4Head, lWn4Body, 'WINDOW 4')
  333.     OpenWindow(lWind5T, lWind5L, lWind5B, lWind5R, lWn5Frame, lWn5Head, lWn5Body, 'WINDOW 5')
  334.     HelpMsg('Press any key...')
  335.     inkey(0)
  336.     ClosWindow()
  337.     ClosWindow()
  338.     ClosWindow()
  339.     ClosWindow()
  340.     ClosWindow()
  341.     exit
  342.   endif
  343.   if lastkey() = kEsc
  344.     ClosWindow()
  345.     exit
  346.   endif
  347. enddo
  348. pExplode   = lExplode
  349. pExpFactor = lExpFactor
  350. pExpDelay  = lExpDelay
  351. pShadow    = lShadow
  352. return
  353.  
  354.  
  355. *
  356. procedure BarDemo
  357. *---------------*
  358.  
  359. private lTop, lLeft, lBottom, lRight, lFramColor, lHeadColor, lBodyColor
  360. private lScalColor, lBarColor, I, lLoopCount
  361.  
  362. lTop    = 7
  363. lLeft   = 33
  364. lBottom = lTop + 4
  365. lRight  = lLeft + 35
  366.  
  367. if iscolor()
  368.   lFramColor = 'W/RB'
  369.   lHeadColor = 'W+/RB'
  370.   lBodyColor = 'N/RB,GR+/RB'
  371.   lScalColor = 'W/RB'
  372.   lBarColor  = 'W+/RB'
  373. else
  374.   lFramColor = 'W+/N'
  375.   lHeadColor = 'W+/N'
  376.   lBodyColor = 'W/N,N/W,,,W+/N'
  377.   lScalColor = 'W/N'
  378.   lBarColor  = 'W/N'
  379. endif
  380.  
  381. OpenWindow(lTop, lLeft, lBottom, lRight, lFramColor, lHeadColor, lBodyColor,;
  382.            'Percentage Complete Bar Demo')
  383.  
  384. @ lTop+1, lLeft+2 say 'Iteration:              Complete'
  385.  
  386. * Initialize and draw the bar scale
  387. InitBar(lTop+3, lLeft+2, 32, lScalColor, lBarColor)
  388. setcolor(GetColor(5))
  389.  
  390. * Initialize the denominator ( Hint: This could be RECCOUNT() )
  391. lLoopCount = 250
  392.  
  393. * Perform the process
  394. HelpMsg('So why are you reading this?  The action is up above '+chr(24)+'')
  395. for I = 1 to lLoopCount
  396.  
  397.   * Display some statistical fluff
  398.   @ lTop+1, lLeft+13 say I pict '999'
  399.   @ lTop+1, lLeft+21 say int(I/lLoopCount * 100) pict '999%'
  400.  
  401.   * Graphically show the percentage
  402.   AdvanceBar(I/lLoopCount) && simple, eh?
  403.  
  404. next
  405.  
  406. ClosWindow()
  407. return
  408.  
  409. *
  410. procedure IsThatAll
  411. *-----------------*
  412.  
  413. lIsT   = 4
  414. lIsL   = 12
  415. lIsB   = lIsT+4
  416. lIsR   = lIsL+53
  417.  
  418. if iscolor()
  419.   lIsFrame = 'B+/B'
  420.   lIsHead  = 'R+*/B'
  421.   lIsBody  = 'G+/B'
  422. else
  423.   lIsFrame = 'N/W'
  424.   lIsHead  = 'W+*/W'
  425.   lIsBody  = 'W+/W'
  426. endif
  427.  
  428. OpenWindow(lIsT, lIsL, lIsB, lIsR, lIsFrame, lIsHead, lIsBody, 'NO!')
  429. @ lIsT+1, lIsL+2 say "That's not all there is but that's the fun stuff."
  430. @ lIsT+2, lIsL+2 say "Just browse around the source code and you'll find"
  431. @ lIsT+3, lIsL+2 say "some interesting things.  Have fun with it!"
  432. HelpMsg('Press any key (well, you know, almost any)...')
  433. inkey(0)
  434. ClosWindow()
  435. return
  436.  
  437.  
  438. *
  439. procedure DispLogo
  440. *----------------*
  441.  
  442. setcolor(lLogo)
  443. @ lLogoT, lLogoL clear to lLogoB, lLogoR
  444. @ lLogoT+1, lLogoL+2  say ' TCMCLIP Demonstration Program '
  445. @ lLogoT+2, lLogoL+2  say '───────────────────────────────'
  446. @ lLogoT+3, lLogoL+2  say "  Clipper Summer '87 Routines  "
  447. @ lLogoT+4, lLogoL+2  say '                               '
  448. @ lLogoT+5, lLogoL+2  say '     by Todd C. MacDonald      '
  449. @ lLogoT+6, lLogoL+2  say '───────────────────────────────'
  450. @ lLogoT+7, lLogoL+2  say '  Placed in the Public Domain  '
  451. return
  452.  
  453.  
  454. procedure EraseLogo
  455. *-----------------*
  456.  
  457. private lLastColor
  458. lLastColor=setcolor(lBackGrnd)
  459. @ lLogoT, lLogoL, lLogoB, lLogoR box replicate(lBGchar, 9)
  460. setcolor(lLastColor)
  461. return
  462.  
  463.  
  464. procedure ClosSystem
  465. *------------------*
  466.  
  467. private lEndTime, lElapsed, lHours, lMins, lSecs
  468.  
  469. * Calculate elapsed time
  470. lEndTime = time()
  471. lElapsed=elaptime(lStartTime, lEndTime)
  472. lHours=substr(lElapsed, 1, 2)
  473. lHours=if(left(lHours,1)='0', right(lHours,1), lHours)
  474. lHours=if(val(lHours) > 0, lHours+' Hour'+if(val(lHours)>1, 's ', ' '), '')
  475. lMins=substr(lElapsed, 4, 2)
  476. lMins=if(left(lMins,1)='0', right(lMins,1), lMins)
  477. lMins=if(val(lMins) > 0, lMins+' Minute'+if(val(lMins)>1, 's ', ' ') , '')
  478. lSecs=substr(lElapsed, 7, 2)
  479. lSecs=if(left(lSecs,1)='0', right(lSecs,1), lSecs)
  480. lSecs=if(val(lSecs) > 0, lSecs+' Second'+if(val(lSecs)>1, 's', '') , '')
  481.  
  482. * Display elapsed time and quit
  483. OpenWindow(lCloseT, lCloseL, lCloseB, lCloseR, lClosFrame, lClosHead, lClosBody, '')
  484. @ lCloseT+2, lCloseL+1 say CJustify('This program was active for:', lCloseR-lCloseL-1)
  485. @ lCloseT+4, lCloseL+1 say CJustify(lHours+lMins+lSecs, lCloseR-lCloseL-1)
  486. setcolor(GetColor(2))
  487. @ lCloseT+6, lCloseL+1 say CJustify('Enjoy!', lCloseR-lCloseL-1)
  488. return
  489.  
  490.  
  491. *
  492. * ────────────── Include the following routines in your source ──────────────
  493.  
  494. * MISCELLANEOUS PROCEDURES & FUNCTIONS
  495.  
  496. procedure Beep
  497. *------------*
  498.  
  499. * Author:  Todd C. MacDonald
  500. * Syntax:  Beep()
  501. * Purpose: Produces a tone on the speaker.
  502. *
  503. tone(300,1)
  504. return
  505.  
  506.  
  507. function ValidFileN
  508. *-----------------*
  509.  
  510. * Author:  Todd C. MacDonald
  511. * Syntax:  ValidFileN( <expC1>, <expC2>, <expC2> )
  512. * Where:   <expC1> is the filename (excluding extension) to be validated
  513. *          <expC2> is the extension to append to <expC1> when testing for
  514. *            the files' existence in the current subdirectory
  515. *          <expC3> is a list of filenames in the form of "FILE1,FILE2,FILE3"
  516. *            to exclude as valid filenames
  517. * Returns: True if the file name <expC1> adheres to DOS filename restrictions,
  518. *          does not exist in the current directory, and is not included in the
  519. *          list of filenames passed in <expC2>.
  520. *
  521. parameter lFileName, lExtension, lExclude
  522. private I
  523. lFileName = alltrim(lFileName)
  524. for I = 1 to len(lFileName)
  525.   if substr(lFileName, I, 1) $'."/\[]:|<>+=;,' .or. asc(substr(lFileName, I, 1)) < 33
  526.     return .f.
  527.   endif
  528. next
  529. if file(lFileName+'.'+lExtension)
  530.   return .f.
  531. endif
  532. if (','+lFileName+',' $lExclude) .or. (len(lFileName) = 0)
  533.   return .f.
  534. endif
  535. return .t.
  536.  
  537.  
  538. function ValidInkey
  539. *-----------------*
  540.  
  541. * Author:  Todd C. MacDonald
  542. * Syntax:  ValidInkey( <expC> )
  543. * Where:   <expC> is a string of valid characters
  544. * Returns: The uppercased character representation of the key pressed if it is
  545. *          contained in <expC>; or Null ('') if the user pressed Esc.
  546. *
  547. parameters lKeySet
  548. private lKey
  549. lKey = inkey(0)
  550. do while (.not. upper(chr(lKey)) $lKeySet) .and. (lKey <> kEsc)
  551.   lKey = inkey(0)
  552. enddo
  553. if lKey <> kEsc
  554.   return upper(chr(lKey))
  555. else
  556.   return ''
  557. endif
  558.  
  559.  
  560.  
  561. * STRING FUNCTIONS
  562.  
  563. function LeftPad
  564. *--------------*
  565.  
  566. * Author:  Todd C. MacDonald
  567. * Syntax:  LeftPad( <expC1>, <expC2>, <expN> )
  568. * Where:   <expC1> is a character string
  569. *          <expC2> is the character to pad <expC1> with
  570. *          <expN>  is the length of the resulting string
  571. * Returns: <expC1> with leading <expC2>'s in a field of <expN> length
  572. *
  573. parameters lString, lChar, lLen
  574. lString=ltrim(rtrim(lString))
  575. return replicate(lChar,lLen-len(lString))+lString
  576.  
  577.  
  578. function ZeroFill
  579. *---------------*
  580.  
  581. * Author:  Todd C. MacDonald
  582. * Syntax:  ZeroFill( <expC>, <expN> )
  583. * Where:   <expC> is a character string
  584. *          <expN> is the length of the resulting string
  585. * Returns: <expC> with leading zeros in a field of <expN> length
  586. *
  587. parameters lString, lLen
  588. lString=ltrim(rtrim(lString))
  589. return replicate('0',lLen-len(lString))+lString
  590.  
  591.  
  592. function LJustify
  593. *---------------*
  594.  
  595. * Author:  Todd C. MacDonald
  596. * Syntax:  LJustify( <expC>, <expN> )
  597. * Where:   <expC> is a character string
  598. *          <expN> is the length of the resulting string
  599. * Returns: <expC> left justified in a field of <expN> spaces
  600. *
  601. parameters lString, lLen
  602. return lString+space(lLen-len(lString))
  603.  
  604.  
  605. function RJustify
  606. *---------------*
  607.  
  608. * Author:  Todd C. MacDonald
  609. * Syntax:  RJustify( <expC>, <expN> )
  610. * Where:   <expC> is a character string
  611. *          <expN> is the length of the resulting string
  612. * Returns: <expC> right justified in a field of <expN> spaces
  613. *
  614. parameters lString, lLen
  615. return space(lLen-len(lString))+lString
  616.  
  617.  
  618. function CJustify
  619. *---------------*
  620.  
  621. * Author:  Todd C. MacDonald
  622. * Syntax:  CJustify( <expC>, <expN> )
  623. * Where:   <expC> is a character string
  624. *          <expN> is the length of the resulting string
  625. * Returns: <expC> centered in a field of <expN> spaces
  626. *
  627. parameters lString, lLen
  628. lString=space(int((lLen-len(lString))/2))+lString
  629. return lString+space(lLen-len(lString))
  630.  
  631.  
  632. function NextAt
  633. *-------------*
  634.  
  635. * Author:  Todd C. MacDonald
  636. * Syntax:  NextAt( <expC1>, <expC2>, <expN> )
  637. * Where:   <expC1> is the character string to search for within <expC2>
  638. *          <expC2> is the character string to search
  639. *          <expN>  is the position within <expC2> to begin the search
  640. * Returns: A number corresponding to the position of <expC1> in <expC2> starting
  641. *          from postition <expN>.
  642. *
  643. parameters lTarget, lString, lStartPos
  644. private lTempStr
  645. lTempStr = right(lString, len(lString)-lStartPos+1)
  646. lAtPos = at(lTarget, lTempStr)
  647. return if(lAtPos <> 0, lStartPos+lAtPos-1, 0)
  648.  
  649.  
  650. function Lotus2Chr
  651. *----------------*
  652.  
  653. * Author:  Todd C. MacDonald
  654. * Syntax:  Lotus2Chr( <expC> )
  655. * Where:   <expC> is a character string in the form of "\999\999\..."
  656. * Returns: Lotus style printer setup string <expC> converted to a character
  657. *          string transmittable to the printer.
  658. *
  659. parameters lLotusStr
  660. private lChrStr, lVal, lStartPos
  661. lLotusStr = alltrim(lLotusStr)
  662. lChrStr = ''
  663. lStartPos = at('\', lLotusStr)
  664. do while lStartPos <> 0
  665.   lEndPos = NextAt('\', lLotusStr, lStartPos+1)
  666.   if lEndPos <> 0
  667.     lChrStr = lChrStr + chr(val(substr(lLotusStr, lStartPos+1, lEndPos-lStartPos-1)))
  668.   else
  669.     lChrStr = lChrStr + chr(val(substr(lLotusStr, lStartPos+1, len(lLotusStr))))
  670.   endif
  671.   lStartPos = lEndPos
  672. enddo
  673. return lChrStr
  674.  
  675.  
  676.  
  677. * SCREEN RELATED PROCEDURES AND FUNCTIONS
  678.  
  679. procedure ReadGets
  680. *----------------*
  681.  
  682. * Author:  Todd C. MacDonald
  683. * Syntax:  ReadGets()
  684. * Purpose: Normal Clipper READ except turn the cursor on before and off after.
  685. *
  686. set cursor on
  687. read
  688. set cursor off
  689. return
  690.  
  691.  
  692. function GetColor
  693. *---------------*
  694.  
  695. * Author:  Todd C. MacDonald
  696. * Syntax:  GetColor( <expN> )
  697. * Where:   <expN> is the logical position of the color in a SETCOLOR() string
  698. * Returns: A string representing the current color (Standard, Enhanced, Border
  699. *          Background, Unselected) pointed to by <expN>.
  700. *
  701. parameters lColorPos
  702. private lColorStr, I, lCommaPos1, lCommaPos2
  703. lColorStr = setcolor()
  704. lCommaPos1 = at(',', lColorStr)
  705. if lColorPos = 1
  706.   return left(lColorStr, if(lCommaPos1 <> 0, lCommaPos1 - 1, len(lColorStr)))
  707. else
  708.   for I = 3 to lColorPos
  709.     if lCommaPos1 = 0
  710.       exit
  711.     endif
  712.     lCommaPos1 = NextAt(',', lColorStr, lCommaPos1 + 1)
  713.   next
  714.   lCommaPos2 = NextAt(',', lColorStr, lCommaPos1 + 1)
  715.   return substr(lColorStr, lCommaPos1+1, if(lCommaPos2 <> 0, lCommaPos2 - 1, len(lColorStr)) - lCommaPos1)
  716. endif
  717.  
  718.  
  719. function GetFGClrNo
  720. *-----------------*
  721.  
  722. * Author:  Todd C. MacDonald
  723. * Syntax:  GetFGClrNo( <expN> )
  724. * Where:   <expN> is the logical position of the color in a SETCOLOR() string
  725. * Returns: A number representing the current color (Standard, Enhanced, Border
  726. *          Background, Unselected) pointed to by <expN>.  You can use this to
  727. *          feed Rick Whitt's SCRNPLAY functions.
  728. *
  729. parameters lColorPos
  730. private lColorTable, lColor
  731. lColorTable = 'N  B  G  BG R  RB GR W  N+ B+ G+ BG+R+ RB+GR+W+ '
  732. lColor = alltrim(strtran(GetColor(lColorPos), '*'))
  733. lColor = if(at('/', lColor) <> 0, left(lColor, at('/', lColor)-1), lColor)
  734. lColor = lColor + space(3-len(lColor))
  735. return (at(lColor, lColorTable)-1)/3
  736.  
  737.  
  738. function GetBGClrNo
  739. *-----------------*
  740.  
  741. * Author:  Todd C. MacDonald
  742. * Syntax:  GetFGClrNo( <expN> )
  743. * Where:   <expN> is the logical position of the color in a SETCOLOR() string
  744. * Returns: A number representing the current color (Standard, Enhanced, Border
  745. *          Background, Unselected) pointed to by <expN>.  You can use this to
  746. *          feed Rick Whitt's SCRNPLAY functions.
  747. *
  748. parameters lColorPos
  749. private lColorTable, lColor
  750. lColorTable = 'N  B  G  BG R  RB GR W  N+ B+ G+ BG+R+ RB+GR+W+ '
  751. lColor = alltrim(strtran(GetColor(lColorPos), '*'))
  752. lColor = if(at('/', lColor) <> 0, right(lColor, len(lColor)-at('/', lColor)), lColor)
  753. lColor = lColor + space(3-len(lColor))
  754. return (at(lColor, lColorTable)-1)/3
  755.  
  756.  
  757. function MakeBlink
  758. *----------------*
  759.  
  760. * Author:  Todd C. MacDonald
  761. * Syntax:  MakeBlink( <expN> )
  762. * Where:   <expN> is the logical position of the color in a SETCOLOR() string
  763. * Returns: A string representing the current color (Standard, Enhanced, Border
  764. *          Background, Unselected) pointed to by <expN> with an '*' added to
  765. *          make the color blink.
  766. *
  767. parameter lColorPos
  768. private lColorStr
  769. lColorStr = GetColor(lColorPos)
  770. return stuff(lColorStr, at('/', lColorStr), 0, '*')
  771.  
  772.  
  773. procedure Center
  774. *--------------*
  775.  
  776. * Author:  Todd C. MacDonald
  777. * Syntax:  Center( <expN1>, <expN2>, <expN3>, <expC> )
  778. * Where:   <expN1> is the row
  779. *          <expN2> is the left column
  780. *          <expN3> is the right column
  781. *          <expC>  is the string to center
  782. * Purpose: Centers <expC> between the columns indicated by <expN2> and <expN3>
  783. *          on the line indicated by <expN1>.
  784. *
  785. parameters  lRow, lLCol, lRCol, lMsg
  786.  
  787. @ lRow, lLCol+int((lRCol-lLCol+1-len(lMsg))/2) say lMsg
  788. return
  789.  
  790.  
  791. procedure InitMenu
  792. *----------------*
  793.  
  794. * Author:  Todd C. MacDonald
  795. * Syntax:  InitMenu( <expN1>, <expC1>, <expC2>,;
  796. *                    <expN2>, <expN3>, <expN4>, <expN5> )
  797. * Where:   <expN1> is the number of options in the menu
  798. *          <expC1> is the SETCOLOR() type string of the unselected options
  799. *          <expC2> is the SETCOLOR() type string of the selected option
  800. *          <expN2> and <expN3> are the foreground and background attributes used
  801. *            to highlight the unselected options trigger letters
  802. *          <expN4> and <expN5> are the foreground and background attributes used
  803. *            to highlight the currently selected options' trigger letter.
  804. * Purpose: Initializes the variables used by the MenuPrompt and MenuChoice
  805. *          procedures.
  806. *
  807. parameter lNbrItems, lNormal, lHilite, lSelectF, lSelectB, lSelectFHi, lSelectBHi
  808. public aMnuRow[lNbrItems], aMnuCol[lNbrItems]
  809. public aMnuPrompt[lNbrItems], aMnuSelect[lNbrItems], pMnuChars
  810. public pMnuNbr, pMnuItem
  811. public pMnuNormal, pMnuHilite, pMnuSelF, pMnuSelB, pMnuSelFHi, pMnuSelBHi
  812. pMnuNbr = lNbrItems
  813. pMnuItem = 1
  814. pMnuChars = ''
  815. pMnuNormal = lNormal
  816. pMnuHilite = lHilite
  817. pMnuSelF   = lSelectF
  818. pMnuSelB   = lSelectB
  819. pMnuSelFHi = lSelectFHi
  820. pMnuSelBHi = lSelectBHi
  821. return
  822.  
  823.  
  824. procedure MenuPrompt
  825. *------------------*
  826.  
  827. * Author:  Todd C. MacDonald
  828. * Syntax:  InitMenu( <expN1>, <expN2>, <expC1>, <expN3> )
  829. * Where:   <expN1> is the row on which the menu prompt <expC1> is to appear
  830. *          <expN2> is the column at which the menu prompt <expC1> is to appear
  831. *          <expC1> is the menu prompt
  832. *          <expN3> is the position of the "trigger" letter within <expC1>
  833. * Purpose: Initializes the variables used in the MenuChoice procedure.
  834. *
  835. parameters lRow, lCol, lPrompt, lSelectPos
  836. aMnuRow[pMnuItem]     = lRow
  837. aMnuCol[pMnuItem]     = lCol
  838. aMnuPrompt[pMnuItem]  = lPrompt
  839. aMnuSelect[pMnuItem]  = lSelectPos - 1
  840. pMnuChars = pMnuChars + upper(substr(lPrompt, lSelectPos, 1))
  841. pMnuItem = pMnuItem + 1
  842. return
  843.  
  844.  
  845. function MenuChoice
  846. *-----------------*
  847.  
  848. * Author:  Todd C. MacDonald
  849. * Syntax:  MenuChoice( <expN> )
  850. * Where:   <expN> is the number of prompt to highlight initially
  851. * Purpose: Displays the prompts created by the MenuPrompt procedure and lets the
  852. *          user select an option either by highlighting it and pressing [Enter]
  853. *          or by typing the "trigger" letter.
  854. * Returns: The number corresponding to the option selected (Zero if [Esc] was
  855. *          pressed).
  856. * Notes:   This procedure necessitates linking in the Rick Whitt's CHGATTR.OBJ
  857. *          file.
  858. *
  859. parameter lMnuItem
  860. private lOrigColor, I
  861. lOrigColor = setcolor(pMnuNormal)
  862. for I = 1 to pMnuNbr
  863.   @ aMnuRow[I], aMnuCol[I] say aMnuPrompt[I]
  864.   chgattr(aMnuRow[I], aMnuCol[I]+aMnuSelect[I], aMnuRow[I], aMnuCol[I]+aMnuSelect[I], pMnuSelF, pMnuSelB)
  865. next
  866. do while .t.
  867.   setcolor(pMnuHilite)
  868.   @ aMnuRow[lMnuItem], aMnuCol[lMnuItem] say aMnuPrompt[lMnuItem]
  869.   chgattr(aMnuRow[lMnuItem], aMnuCol[lMnuItem]+aMnuSelect[lMnuItem], aMnuRow[lMnuItem], aMnuCol[lMnuItem]+aMnuSelect[lMnuItem], pMnuSelFHi, pMnuSelBHi)
  870.   if nextkey() <> kEnter
  871.     keyboard ''
  872.   endif
  873.   lMnuKey = inkey(0)
  874.   setcolor(pMnuNormal)
  875.   @ aMnuRow[lMnuItem], aMnuCol[lMnuItem] say aMnuPrompt[lMnuItem]
  876.   chgattr(aMnuRow[lMnuItem], aMnuCol[lMnuItem]+aMnuSelect[lMnuItem], aMnuRow[lMnuItem], aMnuCol[lMnuItem]+aMnuSelect[lMnuItem], pMnuSelF, pMnuSelB)
  877.   do case
  878.     case (lMnuKey = kDarrow) .or. (lMnuKey = kRarrow)
  879.       lMnuItem = lMnuItem + 1
  880.       if lMnuItem > pMnuNbr
  881.         lMnuItem = 1
  882.       endif
  883.     case (lMnuKey = kUarrow) .or. (lMnuKey = kLarrow)
  884.       lMnuItem = lMnuItem - 1
  885.       if lMnuItem < 1
  886.         lMnuItem = pMnuNbr
  887.       endif
  888.     case lMnuKey = kHome
  889.       lMnuItem = 1
  890.     case lMnuKey = kEnd
  891.       lMnuItem = pMnuNbr
  892.     case upper(chr(lMnuKey)) $pMnuChars
  893.       lMnuItem = at(upper(chr(lMnuKey)), pMnuChars)
  894.       keyboard chr(kEnter)
  895.     case lMnuKey = kEnter
  896.       setcolor(lOrigColor)
  897.       return lMnuItem
  898.     case lMnuKey = kEsc
  899.       setcolor(lOrigColor)
  900.       return 0
  901.  endcase
  902. enddo
  903.  
  904.  
  905. procedure InitBar
  906. *---------------*
  907.  
  908. * Author:  Todd C. MacDonald
  909. * Syntax:  InitBar( <expN1>, <expN2>, <expN3>, <expC1>, <expC2> ] )
  910. * Where:   <expN1> is the screen row to display the scale at
  911. *          <expN2> is the screen column to display the scale at
  912. *          <expN3> is the width (in characters) of the scale
  913. *          <expC1> is the color used for the scale (default: "W/N")
  914. *          <expC2> is the color used for the bar   (default: "W+/N")
  915. * Purpose: Initializes variables used by the AdvanceBar procedure and Displays a
  916. *          "scale" of length <expN3> at row <expN1>, column <expN2> in the color
  917. *          specified by <expC1>.  Subsequent calls to AdvanceBar will cause the
  918. *          "bar" (displayed in the color specified by <expC2>) to advance
  919. *          reflecting the current percentage.
  920. *
  921. parameters lRow, lCol, lWidth, lScaleColr, lBarColor
  922. public pBarRow, pBarCol, pBarWidth, pScaleColr, pBarColor, pBarStep
  923. private lOrigColor
  924. pBarRow    = lRow
  925. pBarCol    = lCol
  926. pBarWidth  = lWidth
  927. pScaleColr = if(pcount() > 3, lScaleColr, "W/N")
  928. pBarColor  = if(pcount() > 4, lBarColor, "W+/N")
  929. pBarStep   = 100 / pBarWidth / 100
  930. lOrigColor = setcolor(pScaleColr)
  931. @ pBarRow, pBarCol say replicate('░', pBarWidth)
  932. setcolor(lOrigColor)
  933. return
  934.  
  935.  
  936. procedure AdvanceBar
  937. *------------------*
  938.  
  939. * Author:  Todd C. MacDonald
  940. * Syntax:  AdvanceBar( <expN> )
  941. * Where:   <expN> is a number less than or equal to 1
  942. * Purpose: Used in conjunction with the InitBar procedure.  Paints the bar on
  943. *          the scale reflecting the current percentage passed in as a parameter.
  944. *
  945. parameters lPercent
  946. private lOrigColor
  947. lOrigColor = setcolor(pBarColor)
  948. if lPercent < 1
  949.   @ pBarRow, pBarCol say replicate('█', int(lPercent/pBarStep))
  950. else
  951.   @ pBarRow, pBarCol say replicate('█', pBarWidth)
  952. endif
  953. setcolor(lOrigColor)
  954. return
  955.  
  956.  
  957. procedure ExplodeBox
  958. *------------------*
  959.  
  960. * Author:  Todd C. MacDonald
  961. * Syntax:  ExplodeBox( <expN1>, <expN2>, <expN3>, <expN4>, <expC> )
  962. * Where:   <expN1> is the top row
  963. *          <expN2> is the left column
  964. *          <expN3> is the bottom row
  965. *          <expN4> is the right column
  966. *          <expC>  is a string of box drawing characters (same as @ BOX)
  967. * Purpose: Displays a succession of boxes on the screen creating an exploding
  968. *          effect.  The explosion stops when it reaches the borders specified
  969. *          by <expN1> through <expN4> (Top, Left, Bottom, Right, respectively).
  970. *          The characters used to draw the boxes are passed in <expC>.
  971. *
  972. parameters lTop, lLeft, lBottom, lRight, lFrame
  973. private lXT, lXL, lXB, lXR, lTReached, lLReached
  974. * Also references public variable pExpFactor, pExpDelay
  975.  
  976. * Determine top & bottom starting lines
  977. lXT = lTop
  978. lXB = lBottom
  979. do while .t.
  980.   lXT = lXT + pExpFactor
  981.   lXB = lXB - pExpFactor
  982.   if lXT >= lXB
  983.     lXT = lXT - pExpFactor
  984.     lXB = lXB + pExpFactor
  985.     exit
  986.   endif
  987. enddo
  988.  
  989. * Determine left & right starting columns
  990. lXL = lLeft
  991. lXR = lRight
  992. do while .t.
  993.   lXL = lXL + pExpFactor * 2
  994.   lXR = lXR - pExpFactor * 2
  995.   if lXL >= lXR
  996.     lXL = lXL - pExpFactor * 2
  997.     lXR = lXR + pExpFactor * 2
  998.     exit
  999.   endif
  1000. enddo
  1001.  
  1002. * Explode the frame
  1003. store .f. to lTReached, lLReached
  1004. do while .not. (lTReached .and. lLReached)
  1005.   @ lXT, lXL, lXB, lXR box lFrame
  1006.   * decrement top, increment bottom
  1007.   if lXT > lTop
  1008.     lXT = lXT - pExpFactor
  1009.     lXB = lXB + pExpFactor
  1010.   else
  1011.     lTReached = .t.
  1012.   endif
  1013.   * decrement left, increment right
  1014.   if lXL > lLeft
  1015.     lXL = lXL - pExpFactor * 2
  1016.     lXR = lXR + pExpFactor * 2
  1017.   else
  1018.     lLReached = .t.
  1019.   endif
  1020.   for I = 1 to pExpDelay
  1021.   next
  1022. enddo
  1023. return
  1024.  
  1025.  
  1026. procedure OpenWindow
  1027. *------------------*
  1028.  
  1029. * Author:  Todd C. MacDonald
  1030. * Syntax:  OpenWindow( <expN1>, <expN2>, <expN3>, <expN4>,;
  1031. *                      <expC1>, <expC2>, <expC3>, <expC4>,;
  1032. *                      [[ <expL1> ], <expL2> ] )
  1033. * Where:   <expN1> is the top row
  1034. *          <expN2> is the left column
  1035. *          <expN3> is the bottom row
  1036. *          <expN4> is the right column
  1037. *          <expC1> is a SETCOLOR() string representing the color of the Frame
  1038. *          <expC2> is a string representing the color of the Header
  1039. *          <expC3> is a string representing the color of the Body of the window
  1040. *          <expC4> is a string containing the text of the window header
  1041. *          <expL1> is true to explode the window; false otherwise (overrides pExplode)
  1042. *          <expL2> is true to paint a shadow; false otherwise (overrides pShadow)
  1043. * Purpose: Displays a window on the screen whose borders are specified by
  1044. *          <expN1> through <expN4>.  The colors of the window are specified in
  1045. *          <expC1> through <expC3>.  If <expL1> is true, the window will
  1046. *          "explode" onto the screen.  If the public variable pShadow is true, a
  1047. *          "see-through" shadow will border the right-hand and bottom edges of
  1048. *          the window.
  1049. * Notes:   References the following public variables: pWindIndex, aWindT, aWindL,
  1050. *          aWindL, aWindB, aWindR, aWindow, aWindColor, pWindFrame, pExplode,
  1051. *          pShadow.  This procedure necessitates linking in Rick Whitt's CHGATTR.OBJ
  1052. *          file.
  1053. *
  1054. parameters lTop, lLeft, lBottom, lRight,;
  1055.            lFrameColor, lHeaderColor, lWindowColor,;
  1056.            lHeaderText, lExplode, lShadow
  1057.  
  1058. * Save region of screen to be written over
  1059. pWindIndex=pWindIndex+1
  1060. aWindT[pWindIndex]=lTop
  1061. aWindL[pWindIndex]=lLeft
  1062. aWindB[pWindIndex]=lBottom+if(lBottom+1 <= 24, 1, 0)
  1063. aWindR[pWindIndex]=lRight+if(lRight+2 <= 79, 2, if(lRight+1 <= 79, 1, 0))
  1064. aWindow[pWindIndex]=savescreen(aWindT[pWindIndex], aWindL[pWindIndex], aWindB[pWindIndex], aWindR[pWindIndex])
  1065.  
  1066. * Draw window
  1067. aWindColor[pWindIndex] = setcolor(lFrameColor)
  1068. if pExplode .and. if(pcount() > 8, lExplode, .t.)
  1069.   ExplodeBox(lTop, lLeft, lBottom, lRight, pWindFrame)
  1070. else
  1071.   @ lTop, lLeft, lBottom, lRight box pWindFrame
  1072. endif
  1073.  
  1074. * Paint shadow
  1075. if if(pcount() < 10, pShadow, lShadow)
  1076.   if lRight+2 <= 79
  1077.     chgattr(lTop+1, lRight+1, lBottom, lRight+2, 7, 0)
  1078.     if lBottom+1 <= 24
  1079.       chgattr(lBottom+1, lLeft+2, lBottom+1, lRight+2, 7, 0)
  1080.     endif
  1081.   elseif lRight+1 <= 79
  1082.     chgattr(lTop+1, lRight+1, lBottom, lRight+1, 7, 0)
  1083.     if lBottom+1 <= 24
  1084.       chgattr(lBottom+1, lLeft+2, lBottom+1, lRight+1, 7, 0)
  1085.     endif
  1086.   elseif lBottom+1 <= 24
  1087.     chgattr(lBottom+1, lLeft+2, lBottom+1, lRight, 7, 0)
  1088.   endif
  1089. endif
  1090.  
  1091. * Display Header
  1092. setcolor(lHeaderColor)
  1093. if pcount() > 7
  1094.   if len(lHeaderText) > 0
  1095.     do Center with lTop, lLeft, lRight, lHeaderText
  1096.   endif
  1097. endif
  1098.  
  1099. * Paint area inside window
  1100. setcolor(lWindowColor)
  1101. @ lTop+1, lLeft+1 clear to lBottom-1, lRight-1
  1102.  
  1103. return
  1104.  
  1105.  
  1106. procedure ClosWindow
  1107. *------------------*
  1108.  
  1109. * Author:  Todd C. MacDonald
  1110. * Syntax:  ClosWindow()
  1111. * Purpose: Erases the last window displayed on the screen using OpenWindow and
  1112. *          restores the area of the screen beneath the window.
  1113. * Notes:   References the following public variables: aWindColor, pWindIndex
  1114. *          aWindT, aWindL, aWindB, aWindR, aWindow
  1115. *
  1116. * Reset previous color attributes
  1117. setcolor(aWindColor[pWindIndex])
  1118.  
  1119. * Restore contents of screen beneath the current window
  1120. restscreen(aWindT[pWindIndex], aWindL[pWindIndex],;
  1121.            aWindB[pWindIndex], aWindR[pWindIndex], aWindow[pWindIndex])
  1122. pWindIndex=pWindIndex-1
  1123.  
  1124. return
  1125.  
  1126.  
  1127. procedure HelpMsg
  1128. *---------------*
  1129.  
  1130. * Author:  Todd C. MacDonald
  1131. * Syntax:  HelpMsg( <expC> )
  1132. * Where:   <expC> is the message to be displayed
  1133. * Purpose: Displays <expC> centered on line 24 of the screen and highlights any
  1134. *          portions of <expC> that are surrounded by the Ctrl-A character.
  1135. * Notes:   References the following public variables: aHelpColor, pHelpHighF,
  1136. *          pHelpHighB. This procedure necessitates linking in Rick Whitt's CHGATTR.OBJ
  1137. *          file.
  1138. *
  1139. parameter lMsg
  1140. private I, lCtrlAPos, aStart[10], aStop[10], lCol, lOrigColor, J
  1141.  
  1142. * DETERMINE START & STOP HIGHLIGHT POSITIONS
  1143. I = 1
  1144. lCtrlAPos = at('', lMsg)
  1145. do while lCtrlAPos > 0
  1146.   aStart[I] = lCtrlAPos
  1147.   lMsg = stuff(lMsg, lCtrlAPos, 1, '')
  1148.   lCtrlAPos = at('', lMsg)
  1149.   aStop[I] = lCtrlAPos-1
  1150.   lMsg = stuff(lMsg, lCtrlAPos, 1, '')
  1151.   I = I + 1
  1152.   lCtrlAPos = at('', lMsg)
  1153. enddo
  1154.  
  1155. * CALCULATE STARTING COLUMN
  1156. lCol = int((80-len(lMsg))/2)
  1157.  
  1158. lOrigColor = setcolor(pHelpColor)
  1159. @ 24, 0
  1160. @ 24, lCol say lMsg
  1161.  
  1162. for J = 1 to I-1
  1163.   chgattr(24, lCol+aStart[J]-1, 24, lCol+aStop[J]-1, pHelpHighF, pHelpHighB)
  1164. next
  1165.  
  1166. setcolor(lOrigColor)
  1167.  
  1168. return
  1169.  
  1170.  
  1171. function Verify
  1172. *-------------*
  1173.  
  1174. * Author:  Todd C. MacDonald
  1175. * Syntax:  Verify( <expC> )
  1176. * Where:   <expC> is a string at some point containing the string "y/n", "Y/n"
  1177. *            or "y/N"
  1178. * Purpose: Displays <expC> centered on line 24 of the screen, highlights the
  1179. *          "y/n" portion, and waits for the user to respond.
  1180. * Returns: True if user types 'Y', false if 'N' or [Esc].  Also will return the
  1181. *          default logical value corresponding to the uppercased letter 'Y' or
  1182. *          or 'N' if the user simply presses [Enter].
  1183. * Notes:   References the following public variables: pHelpColor, pHelpHigh,
  1184. *          pHelpHighF, pHelpHighB.  This function necessitates linking in Rick
  1185. *          Whitt's CHGATTR.OBJ file.
  1186. *
  1187. parameters lQuery
  1188. private lTop, lLeft, lBottom, lRight, lScrnBuf, lOrigColor
  1189. private lKey, lRetVal, lRow, lCol, lY, lN, lYpos, lNpos
  1190.  
  1191. lTop    = 24
  1192. lLeft   = 0
  1193. lBottom = 24
  1194. lRight  = 79
  1195.  
  1196. * save area of screen beneath query & clear it
  1197. lScrnBuf=savescreen(lTop, lLeft, lBottom, lRight)
  1198. lOrigColor = setcolor(pHelpColor)
  1199. @ lTop, lLeft clear to lBottom, lRight
  1200.  
  1201. * display query centered in the given area
  1202. lRow = lTop+int((lBottom - lTop) / 2)
  1203. lCol = lLeft+int((lRight-lLeft+1-len(lQuery))/2)
  1204. @ lRow, lCol say lQuery
  1205.  
  1206. * wait for [Y], [N], [Enter], or [Esc] key to be pressed
  1207. lSlshPos = rat('/', lQuery)
  1208. lY=substr(lQuery, lSlshPos-1, 1)
  1209. lN=substr(lQuery, lSlshPos+1, 1)
  1210. lYpos=lCol + lSlshPos - 1 - 1
  1211. lNpos=lCol + lSlshPos + 1 - 1
  1212. lYes=.t.
  1213. lKey=0
  1214. set color to (pHelpHigh)
  1215. do while .t.
  1216.   if lYes
  1217.     @ lRow, lYpos say lY
  1218.     @ lRow, lNpos say ' '
  1219.     lYes=.f.
  1220.   else
  1221.     @ lRow, lNpos say lN
  1222.     @ lRow, lYpos say ' '
  1223.     lYes=.t.
  1224.   endif
  1225.   lKey = inkey(.2)
  1226.   do case
  1227.     case upper(chr(lKey)) = 'Y' .or. (lKey = 13 .and. lY = 'Y')
  1228.       lRetVal=.t.
  1229.       exit
  1230.     case upper(chr(lKey)) = 'N' .or. lKey = 27 .or. (lKey = 13 .and. lN = 'N')
  1231.       lRetVal=.f.
  1232.       exit
  1233.   endcase
  1234. enddo
  1235.  
  1236. * restore area of screen beneath query
  1237. restscreen(lTop, lLeft, lBottom, lRight, lScrnBuf)
  1238. setcolor(lOrigColor)
  1239.  
  1240. return lRetVal
  1241.  
  1242.  
  1243. procedure Error
  1244. *-------------*
  1245.  
  1246. * Author:  Todd C. MacDonald
  1247. * Syntax:  Error( <expC> )
  1248. * Where:   <expC> is an error message
  1249. * Purpose: Opens an error window in the center of the screen and displays <expC>
  1250. *          wordwrapped within the window.  It then waits for the user to press
  1251. *          [Esc].
  1252. * Notes:   References the following public variables: pErrFrame, pErrHead,
  1253. *          pErrBody
  1254. *
  1255. parameters lErrMsg
  1256. private lTop, lLeft, lBottom, lRight, lNumLines, lLine, lTextLine, lKey
  1257. private lScrnBuff
  1258.  
  1259. lTop=4
  1260. lLeft=18
  1261. lBottom=16
  1262. lRight=61
  1263.  
  1264. OpenWindow(lTop, lLeft, lBottom, lRight, pErrFrame, pErrHead, pErrBody,;
  1265.            ' E R R O R ')
  1266.  
  1267. * DISPLAY THE ERROR MESSAGE
  1268. lNumLines=mlcount(lErrMsg, lRight-lLeft-3)
  1269. for lLine = 1 to lNumLines
  1270.   lTextLine=memoline(lErrMsg, lRight-lLeft-3, lLine)
  1271.   @ lTop+1+lLine-1, lLeft+2 say lTextLine
  1272. next
  1273.  
  1274. lScrnBuff=savescreen(24, 0, 24, 79)
  1275. HelpMsg(' Press Esc to continue...')
  1276. beep()
  1277. beep()
  1278.  
  1279. * WAIT FOR [Esc]
  1280. lKey=0
  1281. do while lKey <> 27
  1282.   lKey=inkey()
  1283. enddo
  1284.  
  1285. ClosWindow()
  1286. restscreen(24, 0, 24, 79, lScrnBuff)
  1287. return
  1288.  
  1289.  
  1290.  
  1291. * ERROR RECOVERY FUNCTIONS
  1292.  
  1293. function Print_Error
  1294. *------------------*
  1295.  
  1296. * Author:  Todd C. MacDonald
  1297. * Purpose: Dresses up Clippers PRINT_ERROR function.
  1298. *
  1299. parameters lName, lLine
  1300. set device to screen
  1301. keyboard '' && clear keyboard buffer
  1302. beep()
  1303. if Verify('PRINTER NOT READY!  Continue? [Y/n]  (pressing "N" will abort this program)')
  1304.   set device to printer
  1305.   return .t.
  1306. else
  1307.   HelpMsg('PROGRAM ABORTED!')
  1308.   close databases
  1309.   set cursor on
  1310.   quit
  1311. endif
  1312.